package ChessLike::Action;
use strict;
use warnings;

=head1 NAME

ChessLike::Action

=head1 VERSION

Version 1.0

=cut

use version; our $VERSION = qv("v1.0");
use ChessLike::Board;
use List::MoreUtils qw( firstidx );

=head1 SYNOPSIS

    use ChessLike::Action;

    $action = ChessLike::Action->new(
       'tile' => 'a1',
       'index' => 0,
       'target-tile' => 'e6',
       'target-index' => 3,
       'type' => 'capture',
       );

    $action = ChessLike::Action->new( 'string' => 'a1+e6.3' );

=cut

{

my @REQUIRED_COMPONENTS = (
   'tile',
   'index',
   'target-tile',
   'target-index',
   #'direction',  # can be undef
   'type',
   );

my @OPTIONAL_ARRAY_COMPONENTS = (
   'possible-directions',
   'links',
   'possible-links',
   );

my @OPTIONAL_HASH_COMPONENTS = (
    'link-destinations'  # link-destinations-by-direction
   );


=head1 API

=head2 new( %action_fields )

 Purpose: Creates a new ChessLike::Action object.
 Required Values: `tile' - Tile containing originating gamepiece
                  `index' - Index of originating gamepiece
                  `target-tile' - Destination tile
                  `target-index' - Destination index
                  `type' - Action type.  Can be 'move', 'capture', 'shot', or 'rotation'
 Optional Values: `direction' - Target direction
                  `possible-directions' - Array of possible rotations
                  `links' - Array of linked units
                  `possible-links' - Array of potential, shared links
                  `link-destinations' - Hash of link destination tiles, keyed by target direction
 Returns: $self
 Throws: Dies if `tile' is not defined.
         Dies if `index' is not defined.
         Dies if `target-tile' is not defined.
         Dies if `target-index' is not defined.
         Dies if `type' is not defined.
 Comment: Exceptions are thrown indirectly via
           ChessLike::Action::validate().
 Comment: This constructor was designed to be used primarily via
          ChessLike::Board::calculate_actions().  Casual developers
          may prefer new( $action_string ).

=head2 new( $action_string )

 Purpose: Creates a new ChessLike::Action object.
 Returns: $self
 Throws: Dies if `tile' is not defined.
         Dies if `index' is not defined.
         Dies if `target-tile' is not defined.
         Dies if `target-index' is not defined.
         Dies if `type' is not defined.
 Comments: Exceptions are thrown indirectly via
           ChessLike::Action::validate().

=cut

sub new {
   my ( $class, %args ) = @_;
   my $self = {};

   foreach ( @REQUIRED_COMPONENTS ) { $self->{$_} = undef; }
   bless $self, $class;

   if ( defined $args{'string'} ) {
      $self->import_string( $args{'string'} );
   }
   else {
      foreach ( keys %args ) { $self->{$_} = $args{$_}; }
   }

   foreach ( @OPTIONAL_ARRAY_COMPONENTS ) {
      $self->{$_} = [] if ( !defined $self->{$_} );
   }
   
   foreach ( @OPTIONAL_HASH_COMPONENTS ) {
      $self->{$_} = {} if ( !defined $self->{$_} );
   }

   $self->validate();
   
   return $self;
}

=head2 validate()

 Purpose: Checks the contents of the action for completeness.
 Returns: 1
 Throws: Dies if `tile' is not defined.
         Dies if `index' is not defined.
         Dies if `target-tile' is not defined.
         Dies if `target-index' is not defined.
         Dies if `type' is not defined.
 Comments: This method is called automatically when an action
           is created using ChessLike::Action::new().

=cut

sub validate {
   my $self = shift;
   my @missing_components;

   foreach ( @REQUIRED_COMPONENTS ) {
      if ( !defined $self->{$_} ) { push @missing_components, $_; }
   }

   die "Action is missing required elements: "
      . ( join ', ', @missing_components )
      . "\n"
      if @missing_components;

   # TODO: Check that scalar values are scalars and array values are arrays
   
   foreach my $link_type ( 'links', 'possible-links' ) {
       my @formatted_links = map {
           my ( $tile, $index ) = split m{\.}, $_, 2;
           $index = 0 if ( !defined $index );
           $tile .= ".$index" if ( $index > 0);
           return $tile;
       } @{ $self->{$link_type} };
   }

   return 1;
}

=head2 to_string( $want_truncated [optional boolean] )

 Purpose: Exports an action as a string.  If
          $want_truncated is defined, then links
          and rotations (except pure rotation
          actions) are removed.
 Returns: $action_string
 Throws: none

=cut

sub to_string {
   my ( $self, $want_truncated ) = @_;
   my %symbol_for_type = (
      'move' => '-',
      'capture' => '+',
      'shot' => '*',
      'rotation' => '>',
   );
   my $action_string = $self->{'tile'};
   my $index = $self->{'index'};
   my $target_index = $self->{'target-index'};
   my $direction = $self->{'direction'};
   my $links_ref = $self->{'links'};
   my $type = $self->{'type'};
   
   $index = 0 if ( !defined $index );
   $target_index = 0 if ( !defined $target_index || $target_index == -1 );
   my $symbol = $symbol_for_type{ $self->{'type'} };
   
   $action_string .= ".$index" if ( $index != 0 );
   
   if ( $type ne 'rotation' ) {
      $action_string .= $symbol . $self->{'target-tile'};
      $action_string .= ".$target_index" if ( $target_index != 0 );
   }
   else {
       $action_string .= $symbol_for_type{'rotation'};
   }

   return $action_string if ( $want_truncated );

   if ( defined $direction ) {
       if ( $type ne 'rotation' ) {
           $action_string .= $symbol_for_type{'rotation'};
       }
       $action_string .= $direction;
   }

   if ( $type ne 'shot' && @{ $links_ref } > 0 ) {
       my @links;
       foreach my $link ( sort @{ $links_ref } ) {
           my ( $link_string, $link_index ) = split m{\.},
               $link, 2;
           
           $link_string .= ".$link_index"
               if ( defined $link_index && $link_index > 0 );
           
           push @links, $link_string;
       }
       @links = sort @links;
       $action_string .= '/'.join( ',', @links );
   }
   
   return $action_string;
}

=head2 import_string( $action_string )

 Purpose: Creates a ChessLike::Action object from an
          action string.
 Returns: 1
 Throws: none
 Comments: Don't call directly.  Use
           ChessLike::Action->new( 'string' => $string )
           instead.

=cut

sub import_string {
   my ( $self, $action_string ) = @_;

   # Parse action string
   $action_string =~ m{
      \A   # Start of line
      ( [a-z]+ [0-9]+ )  # Capture 'tile'
      (?: \. ( [0-9]+ ) )?  # Capture 'index' [optional]
      ( [-+*] )?  # Capture 'type' [optional]
      ( [a-z]+ [0-9]+ )?  # Capture 'target-tile' [optional]
      (?: \. ( [0-9]+ ) )?  # Capture 'target-index' [optional]
      (?: \> ( [nsew] ) )?  # Capture 'direction' [optional]
      (?: \/ ( [a-z0-9\.,]+ ) )?  # Capture links  [optional]
      \z  # End of line
   }xms;
   
   # Factor out captures
   
   my %type_for_symbol = (
      '-' => 'move',
      '+' => 'capture',
      '*' => 'shot',
      '>' => 'rotation',
   );
   
   $self->{'tile'} = $1;
   $self->{'target-tile'} = defined $4 ? $4 : $self->{'tile'};
   $self->{'direction'} = $6;
   $self->{'index'} = defined $2 ? $2 : 0;
   $self->{'target-index'} = defined $5 ? $5 : 0;
   $self->{'type'} = defined $3 ? $type_for_symbol{$3}
       : $type_for_symbol{'>'};

   my $links_string = defined $7 ? $7 : '';
   
   # Parse linked game pieces
   my @links;
   
   while ( $links_string =~ m{
      ( [a-z]+ [0-9]+ )  # Capture linked tile
      (?: \. ( [0-9]+ ) )?  # Capture linked index [optional]
      ,?  # Stop at comma [optional]
   }gxms ) {

       my ( $link, $index ) = ( $1, $2 );
       $index = 0 if ( !defined $index );
       $link .= ".$index" if ( $index > 0 );

       push @links, $link;
   }
   
   $self->{'links'} = \@links;

   return 1;
}

=head2 tile()

 Purpose: Returns the originating tile for the action.
 Returns: $tile
 Throws: none

=cut

sub tile { return shift->{'tile'}; }

=head2 index()

 Purpose: Returns the originating index for the action.
 Returns: $index
 Throws: none

=cut

sub index { return shift->{'index'}; }

=head2 type()

 Purpose: Returns the action type.
 Returns: $type
 Throws: none
 Comments: $type can be 'move', 'capture', 'shot' or 'rotation'.

=cut

sub type { return shift->{'type'}; }

=head2 target_tile()

 Purpose: Returns the target tile for the action.
 Returns: $target_tile
 Throws: none

=cut

sub target_tile { return shift->{'target-tile'}; }

=head2 target_index()

 Purpose: Returns the target index for the action.
 Returns: $target_index
 Throws: none

=cut

sub target_index { return shift->{'target-index'}; }

=head2 set_direction( $direction )

 Purpose: Sets the target direction for the gamepiece.
 Returns: none
 Throws: Dies if $direction is not [nsew]

=cut

sub set_direction {
    my ( $self, $direction ) = @_;

    die "Error in Chesslike::Action: Direction [$direction]"
        . " is not valid.\n"
            if ( $direction !~ /^[nsew]$/ );

    $self->{'direction'} = $direction;
}

=head2 direction()

 Purpose: Returns the target direction for the gamepiece.
 Returns: $direction
 Throws: none
 Comments: By convention, undef is returned for units
           for which ChessLike::GamePiece::can_rotate()
           returns 0.

=cut

sub direction { return shift->{'direction'} };

=head2 links()

 Purpose: Returns the board locations of all units that
          are linked to the originating game piece.
 Returns: @links
 Throws: none
 Comments: This includes all unshared links, and any number
           of shared links.

=cut

sub links {
    my $self = shift;
    return @{ $self->{'links'} };
}

=head2 shared_links()

 Purpose: Returns the board locations of all units that
          can be linked to more than one unit (including
          the originating unit).
          If a direction has been set for this action,
          then this method will exclude all shared links
          that are blocked by the specified direction.
 Returns: @shared_links
 Throws: none

=cut

sub shared_links {
    my $self = shift;
    my $direction = $self->{'direction'};
    
    if ( defined $direction ) {
        return
            grep {
                defined $self->{'link-destinations'}->{$direction}->{$_}
            } @{ $self->{'possible-links'} };
    }
    else {
        return @{ $self->{'possible-links'} };
    }
}

=head2 unshared_links()

 Purpose: Returns the board locations of all units that
          are linked solely to the originating unit.
 Returns: @unshared_links
 Throws: none

=cut

sub unshared_links {
    my $self = shift;
    my @unshared_links = grep {
        my $link = $_;
        firstidx { $_ eq $link } @{ $self->{'possible-links'} };
    } @{ $self->{'links'} };

    return @unshared_links;
}

=head2 possible_directions()

 Purpose: Returns the possible target directions for the
          gamepiece.
 Returns: @possible_directions
 Throws: none

=cut

sub possible_directions {
    my $self = shift;
    return @{ $self->{'possible-directions'} };
}

=head2 upgrade_link( $shared_link )

 Purpose: Links a shared-link to the originating
          gamepiece.
 Returns: 1
 Throws: Dies if $shared_link is not a shared link.

=cut

sub upgrade_link {
    my ( $self, $arg ) = @_;
    my ( $link, $index ) = split m{\.}, $arg, 2;
    $index = 0 if ( !defined $index );
    $link .= ".$index" if ( $index > 0 );
    
    my $is_possible = firstidx { $_ eq $link }
        @{ $self->{'possible-links'} };

    die "Link [$link] is not a shared link."
        unless ( $is_possible > -1 );

    push @{ $self->{'links'} }, $link;
    
    return 1;
}

=head2 downgrade_link( $shared_link )

 Purpose: Unlinks a shared-link from the originating
          gamepiece.
 Returns: 1
 Throws: Dies if $shared_link is not a shared link.
         Dies if $shared_link is not in the list of links.

=cut

sub downgrade_link {
    my ( $self, $arg ) = @_;
    my ( $link, $index ) = split m{\.}, $arg, 2;
    $index = 0 if ( !defined $index );
    $link .= ".$index" if ( $index > 0 );

    my $is_possible = firstidx { $_ eq $link }
        @{ $self->{'possible-links'} };

    die "Link [$link] is not a shared link."
        unless ( $is_possible > -1 );
    
    my $i = firstidx { $_ eq $link } @{ $self->{'links'} };

    die "Link [$link] does not exist."
        unless ( $i > -1 );
    
    splice( @{ $self->{'links'} }, $i, 1 );
}

=head2 link_destination( $link, $direction )

 Purpose: Returns the destination tile of $link given the
          originating gamepiece's target $direction.
 Returns: $destination_tile
 Throws: Dies if $link does not having a valid destination.

=cut

sub link_destination {
    my ( $self, $raw_link, $direction ) = @_;
    my ( $link, $index ) = split m{\.}, $raw_link, 2;
    $link .= ".$index" if ( defined $index && $index > 0 );
    
    my $destination =
        $self->{'link-destinations'}->{$direction}->{$link};
    
    die "Link [$link] does not have a valid destination for"
        . " direction [$direction]"
            if ( !defined $destination );
    
    return $destination;
}

=head1 AUTHOR

Michael J. Lewis, C<< <mjlewis at ualberta.net> >>

=head1 ACKNOWLEDGEMENTS

=head1 LICENSE AND COPYRIGHT

Copyright 2012 Michael J. Lewis.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut

}
1; # End of ChessLike::Action
